home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / lisp / elk-2_0.lha / elk-2.0 / contrib / zelk / src-zelk / farray.c < prev    next >
Encoding:
C/C++ Source or Header  |  1992-11-13  |  18.6 KB  |  802 lines

  1. /* farray.c zilla - c/foreign arrays for elk
  2.  *
  3.     Portions of this file are Copyright (C) 1991 John Lewis,
  4.     adapted from Elk2.0 by Oliver Laumann.
  5.  
  6.     This file is free software; you can redistribute it and/or modify
  7.     it under the terms of the GNU General Public License as published by
  8.     the Free Software Foundation.
  9.  
  10.     This program is distributed in the hope that it will be useful,
  11.     but WITHOUT ANY WARRANTY; without even the implied warranty of
  12.     MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  13.     GNU General Public License for more details.
  14.  
  15.     You should have received a copy of the GNU General Public License
  16.     along with this program; if not, write to the Free Software
  17.     Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
  18.  
  19.  ****NOTE THE ELK COPYING GC: ALL Object REFERENCES MUST BE GC_LINKED
  20.  ****ACROSS CALLS WHICH MAY ALLOCATE STORAGE.  ALL C VARIABLES WHICH 
  21.  ****ARE ASSIGNED FROM THE ADDRESS OF AN OBJECT MUST BE REASSIGNED
  22.  ****AFTER A GC.
  23.  *
  24.  * todo:        add pointer subtype, list->farray&c
  25.  *              make reading know about array shape
  26.  * note:        considered adding a 'boolean(bit) subtype, decided no:
  27.  *              What would this provide over a 'string array whose
  28.  *              elements are used as bits?  Only storage.
  29.  *              Need some way to set bits and then retrieve the byte
  30.  *              as an integer.  This could be added to a 'boolean subtype,
  31.  *              but it is just as easy to make a (bit-compress <stringarr>)
  32.  *              function.
  33.  * modified
  34.  * 12nov
  35.  * 17oct        elk2
  36.  * 7jul        farray_make_like, farray_copyshape
  37.  * 24jun    bugfix in farray2double
  38.  * 4jun         farray-string conversion
  39.  * 11may        GC CORRECTED; shape reversed so shape[0] is minor.
  40.  * 27apr        farray-of can take bignum as well as fixnum
  41.  * 13apr        -flt, -int conversions now allow string farrays.
  42.  * 12apr        farray clength changed
  43.  * 6apr         farray->shape,ndim
  44.  * 30jan        farray-int,farray-flt
  45.  * 20jan        (farray-of <args>). CHECK- is gc ok on this!?
  46.  *              Also change print syntax to (% ... )
  47.  * 2jan         farray2double
  48.  * 15oct        added magic field to farray.
  49.  * 8oct         decided that 'string' arrays should appear as
  50.  *              byte integers 0..255 rather than as scheme #\chars-
  51.  *              more convenient for parsing byte image files.
  52.  *              Initialize arrays to zero only in farray-make, not
  53.  *              in arrays created by e.g. v-*.
  54.  * 11sep        bug-needed gc protection in several places!
  55.  *              ALSO needed object 'tag' in first element of structure!!
  56.  */
  57.  
  58.  
  59. #include <theusual.h>
  60. #include <constants.h>
  61. #include <scheme.h>
  62. #include <assert.h>
  63. #include <zelk.h>
  64.  
  65. #ifdef CONTAINS
  66. #define FARRAY(o) ((Farray *)POINTER(o))
  67.  
  68. typedef struct farray {
  69.   Object tag;  /* needed by elk gc system */
  70.   int type;
  71.   int len;
  72.   int shape[FARRAY_MAXDIM];      /* used by vector code, minor dim is [0] */
  73.   int ndim;             /* used by vector code */
  74. /* the magic field allows array code to be written for use inside or
  75.    outside of scheme : given an array, test the previous word for magic.
  76.    If so, call scheme to find the length.  If not, obtain length
  77.    from some global or assumption (vec library will work this way).
  78.  */
  79.     /* magic must be immediately before start of data! */
  80.   int4 magic;
  81.   Zbyte data[1];
  82. } Farray;
  83. #endif
  84.  
  85. global int T_Farray;
  86.  
  87. /* Return size in bytes of an farray.  1 is for checkbyte */
  88. #define FARRAYWHOLESIZE(type,len) \
  89.   (sizeof(Farray) + ((type)==T_String ? (len) : (len)*4) + 1)
  90.  
  91. /* size in bytes of just the data */
  92. #define FARRAYDATASIZE(type,len) \
  93.   ((type)==T_String ? (len) : (len)*4)
  94.  
  95. /* change VR.c if this changes !! */
  96. #define FARRAY_MAGIC    77
  97.  
  98. #define Sym_integer     Intern("integer")
  99. #define Sym_real        Intern("real")
  100. #define Sym_string      Intern("string")
  101.  
  102. static char *ENotFarray = "argument is not farray";
  103.  
  104. /**************** make &c ****/
  105.  
  106. Object farray_make(type,len)
  107.   int type;
  108.   int len;
  109. {
  110.   Object F;
  111.   Farray *a;
  112.   char *alias;
  113.   int i;
  114.   Ztrace(("farray_make type=%d len=%d\n",type,len));
  115.  
  116.   if ((type==T_String) || (type==T_Fixnum) || (type==T_Flonum)) /*nothing*/ ;
  117.   else Panic("farray_make: bad type");
  118.  
  119.   F = Alloc_Object(FARRAYWHOLESIZE(type,len),T_Farray,0);
  120.   a = FARRAY(F);
  121.  
  122.   a->tag = Null; /* used by the elk gc system */
  123.   a->type = type;
  124.   a->len = len;
  125.   a->shape[0]=len;
  126.   for( i=1; i < FARRAY_MAXDIM; i++ ) a->shape[i]=0;
  127.   a->ndim=1;
  128.   a->magic = FARRAY_MAGIC;
  129.  
  130.   /* DO NOT zero the array here.  this routine gets called by both
  131.    * the (farray-make) user-level function, and by the various vector
  132.    * functions e.g. v-*.  For the latter, the array is a return value
  133.    * and will always be written into, so it is inefficient to
  134.    * initialize it.  Initialize in (farray-make) only.
  135.    */
  136.  
  137.   alias = (char *)a;
  138.   alias[FARRAYWHOLESIZE(type,len)-1] = FARRAY_MAGIC;
  139.  
  140.   return F;
  141. } /*make*/
  142.  
  143.  
  144. /* make an farray with same type and shape as A
  145.    used often by fvector.c */
  146. Object farray_make_like(A)
  147.   Object A;
  148. {
  149.   Farray *a,*f;
  150.   Object F;
  151.   int i;
  152.   int type,len;
  153.   GC_Node;
  154.  
  155.   a = FARRAY(A);
  156.   type = a->type;
  157.   len = a->len;
  158.  
  159.   GC_Link(A);
  160.   F = farray_make(type,len);
  161.   GC_Unlink;
  162.  
  163.   a = FARRAY(A);
  164.   f = FARRAY(F);
  165.   f->ndim = a->ndim;
  166.   for( i=0; i < a->ndim; i++ ) f->shape[i] = a->shape[i];
  167.  
  168.   return F;
  169. } /*make_like*/
  170.  
  171.  
  172. /* copy shape of A to B.  used by vector code */
  173. void farray_copyshape(A,B)
  174.   Object A,B;
  175. {
  176.   register int i;
  177.   register Farray *a,*b;
  178.   Ztrace(("farray_copyshape\n"));
  179.  
  180.   a = FARRAY(A); b = FARRAY(B);
  181.   if (b->len != a->len) Panic("farray_copyshape");
  182.   b->ndim = a->ndim;
  183.   for( i=0; i < a->ndim; i++ ) b->shape[i] = a->shape[i];
  184.  
  185.   Ztrace(("--farray_copyshape\n"));
  186. } /*copyshape*/
  187.  
  188.  
  189. Object P_farray_make(ptype,len)
  190.   Object ptype,len;
  191. {
  192.   int type;
  193.   Object F;
  194.   Farray *f;
  195.   Error_Tag = "farray";
  196. #ifdef ztrace
  197.   Print_Object(ptype,Standard_Output_Port,0,2,10);
  198. #endif
  199.  
  200.   if (ptype == Sym_real)                type = T_Flonum;
  201.   else if (ptype == Sym_integer)        type = T_Fixnum;
  202.   else if (ptype == Sym_string)         type = T_String;
  203.   else Primitive_Error("bad type");
  204.  
  205.   F = farray_make(type,Get_Integer(len));
  206.   f = FARRAY(F);
  207.  
  208.   /* Initialize arrays created with this (farray-make) primitive */
  209.   Zbzero((char *)f->data,((f->type)==T_String ? (f->len) : ((f->len)*4)));
  210.  
  211.   return F;
  212. } /*P_make*/
  213.  
  214.  
  215. void farray_check(f)
  216.   Object f;
  217. {
  218.   Farray *a;
  219.   char *alias;
  220.  
  221.   Error_Tag = "farray-check";
  222.   if (TYPE(f) != T_Farray) Primitive_Error(ENotFarray);
  223.  
  224.   a = FARRAY(f);
  225.   alias = (char *)a;
  226.  
  227.   if ((a->magic != FARRAY_MAGIC) ||
  228.       (alias[FARRAYWHOLESIZE(a->type,a->len)-1] != FARRAY_MAGIC))
  229.     Primitive_Error("array is corrupted?");
  230. } /*_check*/
  231.  
  232.  
  233. Object P_farray_check(f)
  234.   Object f;
  235. {
  236.   farray_check(f);
  237.   return Null;  
  238. } /*_check*/
  239.  
  240.  
  241. Object P_farray_length(f)
  242.   Object f;
  243. {
  244.   Object rval;
  245.   Error_Tag = "farray-length";
  246.  
  247.   Check_Type(f,T_Farray);
  248.  
  249.   rval = Make_Integer(FARRAY(f)->len);
  250.  
  251.   return rval;
  252. } /*P_length*/
  253.  
  254.  
  255. Object P_farrayp(f)
  256.   Object f;
  257. {
  258.   return (TYPE(f)==T_Farray) ? True : False;
  259. } /*P_p*/
  260.  
  261.  
  262. Object P_farray_type(f)
  263.   Object f;
  264. {
  265.   Farray *a;
  266.  
  267.   Error_Tag = "farray-type";
  268.   if (TYPE(f) != T_Farray) Primitive_Error(ENotFarray);
  269.  
  270.   a = FARRAY(f);
  271.   switch(a->type) {
  272.   case T_Fixnum:        return(Sym_integer); break;
  273.   case T_Flonum:        return(Sym_real); break;
  274.   case T_String:        return(Sym_string); break;
  275.   default:              Panic("farray_type");
  276.   }
  277.   return Null; /*for lint*/
  278. } /*P_type*/
  279.  
  280.  
  281. Object P_farray_copy(f)
  282.   Object f;
  283. {
  284.   Farray *a,*b;
  285.   int i;
  286.   Object f2;
  287.   GC_Node;
  288.   Error_Tag = "farray-copy";
  289.  
  290.   Check_Type(f,T_Farray);
  291.  
  292.   GC_Link(f);
  293.   a = FARRAY(f);
  294.   f2 = farray_make(a->type,a->len);
  295.   GC_Unlink;
  296.  
  297.   a = FARRAY(f);
  298.   b = FARRAY(f2);
  299.  
  300.   Zbcopy(a->data,b->data,FARRAYDATASIZE(a->type,a->len));
  301.  
  302.   /* shape is mainly used by vector code currently */
  303.   for( i=0; i < FARRAY_MAXDIM; i++ )  b->shape[i] = a->shape[i];
  304.   b->ndim = a->ndim;
  305.  
  306.   return f2;
  307. } /*copy*/
  308.  
  309.  
  310. /* make an farray from the provided arguments, e.g.,
  311.  * (farray-of 2. 3.) => [ 2. 3. ]
  312.  * Decided to NOT make this a special syntax for now-
  313.  * Getting the reader to read the closing ] will require changes...
  314.  * Instead, this is bound to the procedure %, and farrays are
  315.  * also printed as (% .... ), so we have read-print equivalence.
  316.  */
  317.  
  318. /* WARNING- not sure if this routine is properly GC protected */
  319.  
  320. Object P_farray_of (argc, argv)
  321.   Object *argv; 
  322. {
  323.   Object F;
  324.   Farray *f;
  325.   int i,type;
  326.   Error_Tag = "farray";
  327.  
  328.   if (argc < 1) Primitive_Error("no items in array");
  329.  
  330.   type = TYPE(argv[0]);
  331.  
  332.   if (type == T_Character)
  333.     F = farray_make(T_String,argc);
  334.   else if (type == T_String)
  335.     F = farray_make(T_String,STRING(argv[0])->size);
  336.   else if (type == T_Bignum)
  337.     F = farray_make(T_Fixnum,argc);
  338.   else
  339.     F = farray_make(type,argc);
  340.   f = FARRAY(F);
  341.  
  342.   switch(type) {
  343.  
  344.   case T_Flonum:
  345.   for( i=0; i < argc; i++ ) {
  346.     Check_Type(argv[i],T_Flonum);
  347.     ((float *)f->data)[i] = FLONUM(argv[i])->val;
  348.   }
  349.   break;
  350.  
  351.   case T_Bignum:
  352.   case T_Fixnum:
  353.   for( i=0; i < argc; i++ ) {
  354.     if ((TYPE(argv[i])!=T_Bignum) && (TYPE(argv[i]!=T_Fixnum)))
  355.       Primitive_Error("mixed types in farray");
  356.     ((int4 *)f->data)[i] = Get_Integer(argv[i]);
  357.   }
  358.   break;
  359.  
  360.   case T_Character:
  361.   for( i=0; i < argc; i++ ) {
  362.     Check_Type(argv[i],T_Character);
  363.     ((char *)f->data)[i] = CHAR(argv[i]);
  364.   }
  365.   break;
  366.  
  367.   case T_String:
  368.   for( i=0; i < STRING(argv[0])->size; i++ ) {
  369.     ((char *)f->data)[i] = STRING(argv[0])->data[i];
  370.   }
  371.   break;
  372.  
  373.   } /*switch(type)*/
  374.  
  375.   return F;
  376. } /*farray-of */
  377.  
  378.  
  379.  
  380. /**************** set and ref ****/
  381.  
  382. Object P_farray_set(f,pidx,pobj)
  383.   Object f,pidx,pobj;
  384. {
  385.   int4 idx;
  386.   Farray *a;
  387.   long *L; float *F; unsigned char *C;
  388.  
  389.   Error_Tag = "farray-set!";
  390.   Check_Type(f,T_Farray);
  391.  
  392.   a = FARRAY(f);
  393.   C = (unsigned char *)a->data;
  394.   F = (float *)a->data;
  395.   L = (long *)a->data;
  396.   idx = Get_Integer(pidx);
  397.   if ((idx < 0) || (idx >= a->len)) Primitive_Error("index out of array");
  398.  
  399.   switch(a->type) {
  400.   case T_Fixnum:
  401.     L[idx] = Get_Integer(pobj); 
  402.     break;
  403.   case T_Flonum: 
  404.     if (TYPE(pobj) != T_Flonum)  Primitive_Error("bad type");
  405.     F[idx] = (double)FLONUM(pobj)->val;
  406.     break;
  407.   case T_String:
  408. /*    if (TYPE(pobj) != T_Character)  Primitive_Error("bad type"); 
  409.     C[idx] = (char)CHAR(pobj); */
  410.     C[idx] = (unsigned char)Get_Integer(pobj);
  411.     break;
  412.   default: Panic("farray_set");
  413.   }
  414.  
  415.   return pobj;
  416. } /*P_set*/
  417.  
  418.  
  419.  
  420. Object P_farray_ref(f,pidx)
  421.   Object f,pidx;
  422. {
  423.   int4 idx;
  424.   Farray *a;
  425.   long *L; float *F; unsigned char *C;
  426.   Object val;
  427.   Error_Tag = "farray-ref";
  428.  
  429.   Check_Type(f,T_Farray);
  430.  
  431.   a = FARRAY(f);
  432.   C = (unsigned char *)a->data;
  433.   F = (float *)a->data;
  434.   L = (long *)a->data;
  435.  
  436.   idx = Get_Integer(pidx);
  437.   if ((idx < 0) || (idx >= a->len)) Primitive_Error("index out of array");
  438.  
  439.   switch(a->type) {
  440.   case T_Fixnum:
  441.     val = Make_Integer((int4)L[idx]);
  442.     break;
  443.   case T_Flonum:
  444.     val = Make_Reduced_Flonum(F[idx]);
  445.     break;
  446.   case T_String:
  447. /*  val = Make_Char(C[idx]); */
  448.     val = Make_Integer((int4)C[idx]);
  449.     break;
  450.   default: Panic("farray_ref");
  451.   }
  452.  
  453.   return val;
  454. } /*P_ref*/
  455.  
  456. /**************** routines called from c programs! ****
  457.  **** when a c program is passed an array but no size,
  458.  **** call these to get the size/type.
  459.  */
  460.  
  461.  
  462. /* given the start of the array data, back up to get the array header. 
  463.  * This does not work, probably because of structure alignment. 
  464.  *    ((Farray *)((char *)a - (sizeof(Farray)-sizeof(char))))
  465.  * This is wierd, but it will work regardless of changes in Farray struct:
  466.  */
  467. static Farray _Junk;
  468. #define FARRAYHDR(a) \
  469.     ((Farray *)((char *)a - ((char *)&_Junk.data[0] - (char *)&_Junk.tag)))
  470.  
  471.  
  472. int farray_clength(a)
  473.   long *a;
  474. {
  475.   Farray *o;
  476.   
  477.   o = FARRAYHDR(a);
  478.   if (o->magic == FARRAY_MAGIC)
  479.     return(o->len);
  480.   else
  481.     return -1;
  482. }
  483.  
  484.  
  485. int farray_ctype(a)
  486.   long *a;
  487. {
  488.   Farray *o;
  489.  
  490.   o = FARRAYHDR(a);
  491.   if (o->magic == FARRAY_MAGIC)
  492.     return(o->type);
  493.   else
  494.     Panic("farray_ctype");
  495. }
  496.  
  497. /*%%%%%%%%%%%%%%%% routines used by elk type creation system %%%%*/
  498.  
  499. static int4 farray_size(f)
  500.   Object f;
  501. {
  502.   Farray *a;
  503.   if (TYPE(f) != T_Farray) Panic("farray_size");
  504.   a = FARRAY(f);
  505.   return( FARRAYWHOLESIZE(a->type,a->len) );
  506. }
  507.  
  508.  
  509. bool farray_equal(a,b)
  510.   Object a,b;
  511. {
  512.   return 0;
  513. }
  514.  
  515.  
  516. void farray_print(f,port,raw,pdepth,plen)
  517.   Object f;
  518.   Object port;
  519.   bool raw;     /* does what? */
  520.   int pdepth, plen;
  521. {
  522.   Farray *a;
  523.   int type,len;
  524.   int4 *L;
  525.   float *F;
  526.   char *format;
  527.  
  528.   if (TYPE(f) != T_Farray) Panic("farray_print");
  529.   a = FARRAY(f);
  530.   type = a->type;
  531.   len = a->len;
  532.   
  533.   switch (type) {
  534.   case T_Fixnum:    format = "%d ";   break;
  535.   case T_Flonum:    format = "%.3f ";   break;
  536.   case T_String:        break;
  537.   default:              Panic ("farray:print");
  538.   } /*switch*/
  539.  
  540.   F = (float *)a->data;
  541.   /* since floats are converted to doubles whenever passed,
  542.    * floats,int4s cannot both be handled with a long *.
  543.    */
  544.   L = (int4 *)a->data;
  545.  
  546.   if (type == T_String) {
  547.     register int i;
  548.     register char *c,*d;
  549.  
  550.     c = (char *)a->data;
  551.     d = Ctmpbuf;
  552.     if (len >= Ctmpbuflen) Panic("farray_print: string too long");
  553.  
  554.     for( i=0; i < len; i++ ) {
  555.       /* do not print null characters */
  556.       if (*c != (char)0)  *d++ = *c;
  557.       c++;
  558.     }
  559.     *d = (char)0;
  560.  
  561.     Printf(port,"[%s]",Ctmpbuf);
  562.   } /*string*/
  563.  
  564.   else if (a->ndim == 2) {    /* print as matrix */
  565.     register int i,j;
  566.     for (i = 0; i < a->shape[1]; i++) {
  567.       Printf(port, "[ ");
  568.       for (j = 0; j < a->shape[0]; j++) {
  569.         if (type == T_Flonum)
  570.           (void)sprintf (Ctmpbuf, format, *F++);
  571.         else
  572.           (void)sprintf (Ctmpbuf, format, *L++);
  573.         Printf(port, Ctmpbuf);
  574.       }
  575.       Printf(port, "]\n");
  576.     }
  577.   } /*matrix*/
  578.  
  579.  
  580.   else {
  581.     register int i;
  582.     Printf(port, "(%% ");
  583.  
  584.     for (i = 0; i < len; i++) {
  585.  
  586.       if (i > plen) {                   /* too big, stop printing */
  587.         Printf(port,"...");
  588.         break;
  589.       }
  590.       if (type == T_Flonum)
  591.         (void)sprintf (Ctmpbuf, format, *F++);
  592.       else
  593.         (void)sprintf (Ctmpbuf, format, *L++);
  594.       Printf(port, Ctmpbuf);
  595.     }
  596.     Printf(port, ")");
  597.   } /*print as array */
  598.  
  599. } /*_print*/
  600.  
  601.  
  602. /**************** type conversion ****************/
  603.  
  604. /* convert float or string array to int */
  605. #define FARRAY_INT    P_farray_int, "farray-int", 1,1,EVAL,
  606. Object 
  607. P_farray_int(A)
  608.   Object A;
  609. {
  610.   register int i,len;
  611.   Object B;
  612.   Farray *a;
  613.   register int4 *ib;
  614.   GC_Node;
  615.   Error_Tag = "farray-int";
  616.  
  617.   Check_Type(A,T_Farray);
  618.  
  619.   a = FARRAY(A);
  620.   /* already integer. return a copy to stay functional- caller may
  621.      be expecting that result is a distinct array */
  622.   if (a->type == T_Fixnum) return P_farray_copy(A);  
  623.   len = a->len;
  624.  
  625.   GC_Link(A);
  626.   B = farray_make(T_Fixnum,len);
  627.   GC_Unlink;
  628.   a = FARRAY(A);        /* reassign after gc */
  629.   ib = (int4 *)FARRAY(B)->data;
  630.  
  631.   if (a->type == T_Flonum) {
  632.     register float *ia = (float *)a->data;
  633.     for( i=0; i < len; i++ ) *ib++ = (int4)*ia++;
  634.   }
  635.   else if (a->type == T_String) {
  636.     register unsigned char *ia = (unsigned char *)a->data;
  637.     for( i=0; i < len; i++ ) *ib++ = (int4)*ia++;
  638.   }
  639.   else Panic("farray-int");
  640.  
  641.   return B;
  642. } /*int*/
  643.  
  644.  
  645.  
  646. /* convert float or int array to string(byte) */
  647. #define FARRAY_STRING    P_farray_string, "farray-string", 1,1,EVAL,
  648. Object 
  649. P_farray_string(A)
  650.   Object A;
  651. {
  652.   register int i,len;
  653.   Object B;
  654.   Farray *a;
  655.   register unsigned char *ib;
  656.   GC_Node;
  657.   Error_Tag = "farray-string";
  658.  
  659.   Check_Type(A,T_Farray);
  660.  
  661.   a = FARRAY(A);
  662.   /* already string. return a copy to stay functional- caller may
  663.      be expecting that result is a distinct array */
  664.   if (a->type == T_String) return P_farray_copy(A);  
  665.   len = a->len;
  666.  
  667.   GC_Link(A);
  668.   B = farray_make(T_String,len);
  669.   GC_Unlink;
  670.   a = FARRAY(A);        /* reassign after gc */
  671.   ib = (unsigned char *)FARRAY(B)->data;
  672.  
  673.   if (a->type == T_Flonum) {
  674.     register float *ia = (float *)a->data;
  675.     for( i=0; i < len; i++ ) *ib++ = (unsigned char)(int)*ia++;
  676.   }
  677.   else if (a->type == T_Fixnum) {
  678.     register int *ia = (int *)a->data;
  679.     for( i=0; i < len; i++ ) *ib++ = (unsigned char)*ia++;
  680.   }
  681.   else Panic("farray-string");
  682.  
  683.   return B;
  684. } /*string*/
  685.  
  686.  
  687. /* convert int or string farray to float */
  688. #define FARRAY_FLT    P_farray_flt, "farray-flt", 1,1,EVAL,
  689. Object P_farray_flt(A)
  690.   Object A;
  691. {
  692.   register int i,len;
  693.   Object B;
  694.   Farray *a;
  695.   register float *ib;
  696.   GC_Node;
  697.   Error_Tag = "farray-flt";
  698.  
  699.   Check_Type(A,T_Farray);
  700.  
  701.   a = FARRAY(A);
  702.   /* already float. return a copy to stay functional- caller may
  703.      be expecting that result is a distinct array */
  704.   if (a->type == T_Flonum) return P_farray_copy(A);  /* already float */
  705.   len = a->len;
  706.  
  707.   GC_Link(A);
  708.   B = farray_make(T_Flonum,len);
  709.   GC_Unlink;
  710.   a = FARRAY(A); /* reassign after gc! */
  711.   ib = (float *)FARRAY(B)->data;
  712.  
  713.   if (a->type == T_Fixnum) {
  714.     register int4 *ia = (int4 *)a->data;
  715.     for( i=0; i < len; i++ ) *ib++ = (float)*ia++;
  716.   }
  717.   else if (a->type == T_String) {
  718.     register unsigned char *ia = (unsigned char *)a->data;
  719.     register int j;
  720.     /* some c compiler could not cast from char to float directly */
  721.     for( i=0; i < len; i++ ) {
  722.       j = *ia++;
  723.       *ib++ = (float)j;
  724.     }
  725.   }
  726.   else Panic("farray-flt");
  727.  
  728.   return B;
  729. } /*flt*/
  730.  
  731.  
  732. /* convert a float farray to the same, of 2x length, containing doubles */
  733. Object P_farray2double(F)
  734.   Object F;
  735. {
  736.   Object D;
  737.   Farray *f,*d;
  738.   float *fp; double *dp;
  739.   int i,len;
  740.   GC_Node;
  741.   Error_Tag = "farray2double";
  742.  
  743.   if (FARRAY(F)->type != T_Flonum)
  744.     Primitive_Error("array is not float");
  745.  
  746.   GC_Link(F);
  747.   D = farray_make(T_Flonum,FARRAY(F)->len*2);
  748.   GC_Unlink;
  749.  
  750.   f = FARRAY(F);
  751.   d = FARRAY(D);
  752.   fp = (float *)f->data;
  753.   dp = (double *)d->data;
  754.   len = f->len;
  755.  
  756.   for( i=0; i < len; i++ ) {
  757.     *dp++ = (double)*fp++;
  758.   }
  759.   
  760.   return D;
  761. } /*P_double*/
  762.  
  763.  
  764. /**************** link ****************/
  765.  
  766. static struct primdef Prims[] = {
  767.   FARRAY_INT
  768.   FARRAY_STRING
  769.   FARRAY_FLT
  770.  
  771.   (Object (*)())0, (char *)0, 0,0,EVAL
  772. };
  773.  
  774.  
  775. void Init_farray()
  776. {
  777.   T_Farray = Define_Type(0,"farray",farray_size,0,
  778.                          farray_equal,farray_equal,
  779.                          farray_print, NOFUNC);
  780.   /* printf("[Init_farray type %d]\n",T_Farray); */
  781.  
  782.   Define_Primitive(P_farray_make,"farray",2,2,EVAL);
  783.   Define_Primitive(P_farrayp,"farray?",1,1,EVAL);
  784.   Define_Primitive(P_farray_check,"farray-check",1,1,EVAL);
  785.  
  786.   Define_Primitive(P_farray_length,"farray-length",1,1,EVAL);
  787.   Define_Primitive(P_farray_type,"farray-type",1,1,EVAL);
  788.   Define_Primitive(P_farray_copy,"farray-copy",1,1,EVAL);
  789.  
  790.   Define_Primitive(P_farray_of,"farray-of",0,MANY,VARARGS);
  791.   Define_Primitive(P_farray_of,"%",0,MANY,VARARGS); /*synonym*/
  792.  
  793.   Define_Primitive(P_farray_set,"farray-set!",3,3,EVAL);
  794.   Define_Primitive(P_farray_ref,"farray-ref",2,2,EVAL);
  795.  
  796.   Define_Primitive(P_farray2double,"farray2double",1,1,EVAL);
  797.  
  798.   ZLprimdeftab(Prims);
  799.  
  800.   P_Provide(Intern("farray.o"));
  801. } /*init*/
  802.